home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / perl / 5.8.8 / constant.pm < prev    next >
Encoding:
Perl POD Document  |  2007-03-05  |  3.0 KB  |  119 lines
  1. package constant;
  2.  
  3. use strict;
  4. use 5.006_00;
  5. use warnings::register;
  6.  
  7. our($VERSION, %declared);
  8. $VERSION = '1.05';
  9.  
  10. #=======================================================================
  11.  
  12. # Some names are evil choices.
  13. my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
  14.  
  15. my %forced_into_main = map +($_, 1),
  16.     qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
  17.  
  18. my %forbidden = (%keywords, %forced_into_main);
  19.  
  20. #=======================================================================
  21. # import() - import symbols into user's namespace
  22. #
  23. # What we actually do is define a function in the caller's namespace
  24. # which returns the value. The function we create will normally
  25. # be inlined as a constant, thereby avoiding further sub calling 
  26. # overhead.
  27. #=======================================================================
  28. sub import {
  29.     my $class = shift;
  30.     return unless @_;            # Ignore 'use constant;'
  31.     my %constants = ();
  32.     my $multiple  = ref $_[0];
  33.  
  34.     if ( $multiple ) {
  35.     if (ref $_[0] ne 'HASH') {
  36.         require Carp;
  37.         Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
  38.     }
  39.     %constants = %{+shift};
  40.     } else {
  41.     $constants{+shift} = undef;
  42.     }
  43.  
  44.     foreach my $name ( keys %constants ) {
  45.     unless (defined $name) {
  46.         require Carp;
  47.         Carp::croak("Can't use undef as constant name");
  48.     }
  49.     my $pkg = caller;
  50.  
  51.     # Normal constant name
  52.     if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
  53.         # Everything is okay
  54.  
  55.     # Name forced into main, but we're not in main. Fatal.
  56.     } elsif ($forced_into_main{$name} and $pkg ne 'main') {
  57.         require Carp;
  58.         Carp::croak("Constant name '$name' is forced into main::");
  59.  
  60.     # Starts with double underscore. Fatal.
  61.     } elsif ($name =~ /^__/) {
  62.         require Carp;
  63.         Carp::croak("Constant name '$name' begins with '__'");
  64.  
  65.     # Maybe the name is tolerable
  66.     } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
  67.         # Then we'll warn only if you've asked for warnings
  68.         if (warnings::enabled()) {
  69.         if ($keywords{$name}) {
  70.             warnings::warn("Constant name '$name' is a Perl keyword");
  71.         } elsif ($forced_into_main{$name}) {
  72.             warnings::warn("Constant name '$name' is " .
  73.             "forced into package main::");
  74.         }
  75.         }
  76.  
  77.     # Looks like a boolean
  78.     # use constant FRED == fred;
  79.     } elsif ($name =~ /^[01]?\z/) {
  80.             require Carp;
  81.         if (@_) {
  82.         Carp::croak("Constant name '$name' is invalid");
  83.         } else {
  84.         Carp::croak("Constant name looks like boolean value");
  85.         }
  86.  
  87.     } else {
  88.        # Must have bad characters
  89.             require Carp;
  90.         Carp::croak("Constant name '$name' has invalid characters");
  91.     }
  92.  
  93.     {
  94.         no strict 'refs';
  95.         my $full_name = "${pkg}::$name";
  96.         $declared{$full_name}++;
  97.         if ($multiple) {
  98.         my $scalar = $constants{$name};
  99.         *$full_name = sub () { $scalar };
  100.         } else {
  101.         if (@_ == 1) {
  102.             my $scalar = $_[0];
  103.             *$full_name = sub () { $scalar };
  104.         } elsif (@_) {
  105.             my @list = @_;
  106.             *$full_name = sub () { @list };
  107.         } else {
  108.             *$full_name = sub () { };
  109.         }
  110.         }
  111.     }
  112.     }
  113. }
  114.  
  115. 1;
  116.  
  117. __END__
  118.  
  119.